home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / package.tcl < prev    next >
Encoding:
Text File  |  1999-11-01  |  40.7 KB  |  1,373 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "package.tcl"
  6.  #                                    created: 2/8/97 {6:15:10 pm} 
  7.  #                                last update: 11/01/1999 {19:52:43 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  # Copyright (c) 1997-1999  Vince Darley, all rights reserved
  14.  # 
  15.  #  How to ensure packages are loaded in the correct order?
  16.  #  (some may require Vince's Additions).  Here perhaps we could
  17.  #  just use a Tcl8-like-approach: introduce a 'package' command
  18.  #  and have stuff like 'package Name 1.0 script-to-load'.
  19.  #  Then a package can just do 'package require Othername' to ensure
  20.  #  it is loaded.  I like this approach.
  21.  #  
  22.  #  How to initialise each package at startup?  If we use the above
  23.  #  scheme, then the startup script is purely a sequence of
  24.  #  'package require Name' commands.  The file 'prefs.tcl' is then
  25.  #  purely for user-meddling.  Packages do not need to store anything
  26.  #  there.  Sounds good to me.
  27.  #  
  28.  #  How to uninstall things?  One approach here is a 
  29.  #  'package uninstall Name' command.  Nice packages would provide
  30.  #  this.
  31.  #  
  32.  #  We need a default behaviour too.  Some packages require no
  33.  #  installation at all (except placing in a directory), others 
  34.  #  require sourcing, others need to add something to a menu.  How
  35.  #  much of this should be automated and how much is up to the
  36.  #  package author?
  37.  # 
  38.  # ----
  39.  # 
  40.  #  The solution below is to imitate Tcl 8.  There is a 'package'
  41.  #  mechanism.  There exists a index::feature() array which gives for
  42.  #  each package the means to load it --- a procedure name or a
  43.  #  'source file' command.  The package index is compiled 
  44.  #  automatically by recursively scanning all files in the
  45.  #  Packages directory for 'package name version do-this'
  46.  #  commands.
  47.  #  
  48.  #  There's also 'package names', 'package exists name', and an
  49.  #  important 'package require name version' which allows one
  50.  #  package to autoload another...
  51.  #  
  52.  # Pros of this approach: many packages, which would otherwise
  53.  # require an installation procedure, now can be just dropped
  54.  # in to the packages directory and they're installed! (After
  55.  # rebuilding the package index).  This is because 'package'
  56.  # can declare a snippet of code, an addition to a menu etc…
  57.  # ----
  58.  # 
  59.  # Thanks to Tom Fetherston for some improvements here.
  60.  # ###################################################################
  61.  ##
  62.  
  63. namespace eval package {}
  64. namespace eval date {}
  65. namespace eval remote {}
  66.  
  67. ## 
  68.  # -------------------------------------------------------------------------
  69.  # 
  70.  # "alpha::findAllExtensions" --
  71.  # 
  72.  #  package require all extensions the user has activated
  73.  # -------------------------------------------------------------------------
  74.  ##
  75. proc alpha::findAllExtensions {} {
  76.     global global::features index::feature alpha::earlyPackages
  77.     foreach m [array names index::feature] {
  78.     if {[lsearch -exact [set global::features] $m] != -1} {
  79.         # it's on
  80.         if {[lsearch -exact [set alpha::earlyPackages] $m] != -1} {
  81.         # We already did this one.
  82.         continue
  83.         }
  84.         package::activate $m
  85.     } else {
  86.         if {[lindex [set index::feature($m)] 2] == 2} {
  87.         package::initialise $m
  88.         }
  89.     }
  90.     }
  91.  
  92.     # remove any package which doesn't exist.
  93.     foreach m [set global::features] {
  94.     if {![info exists index::feature($m)]} {
  95.         set global::features [lremove ${global::features} $m]
  96.     }
  97.     }
  98. }
  99.  
  100. proc package::addPrefsDialog {pkg} {
  101.     global package::prefs alpha::noMenusYet
  102.     lunion package::prefs $pkg
  103.     if {![info exists alpha::noMenusYet]} {
  104.     # we were called after start-up; build the menu now
  105.     menu::buildSome packages
  106.     }
  107. }
  108.  
  109. ## 
  110.  # -------------------------------------------------------------------------
  111.  # 
  112.  # "alpha::package" --
  113.  # 
  114.  #  Mimics the Tcl standard 'package' command for use with Alpha.
  115.  #  It does however have some differences.
  116.  #  
  117.  #  package require ?-exact? ?-extension -mode -menu? name version
  118.  #  package exists ?-extension -mode -menu? name version
  119.  #  package names ?-extension -mode -menu?
  120.  #  package uninstall name version
  121.  #  package vcompare v1 v2
  122.  #  package vsatisfies v1 v2
  123.  #  package versions ?-extension -mode -menu? name
  124.  #  package type name
  125.  #  package info name
  126.  #  package maintainer name version {name email web-page}
  127.  #  package modes 
  128.  #  
  129.  #  Equivalent to alpha::mode alpha::menu and alpha::extension
  130.  #  
  131.  #  package mode ...
  132.  #  package menu ...
  133.  #  package extension ...
  134.  #  
  135.  #  For extensions only:
  136.  #  
  137.  #  package forget name version
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. proc alpha::package {cmd args} {
  141.     global index::feature
  142.     switch -- $cmd {
  143.     "require" {
  144.         set info [package::getInfo "exact loose"]
  145.         global alpha::rebuilding
  146.         if {[llength $info]} {
  147.         if {!${alpha::rebuilding} && [set version [lindex $args 1]] != ""} {
  148.             if {[info exists exact]} {
  149.             if {[lindex $info 0] != $version} {
  150.                 error "requested exact $version, had [lindex $info 0]"
  151.             }
  152.             } elseif {[info exists loose]} {
  153.             if {[alpha::package vcompare [lindex $info 0] $version] < 0} {
  154.                 error "requested $version or newer, had [lindex $info 0]"
  155.             }
  156.             } elseif {![alpha::package vsatisfies [lindex $info 0] $version]} {
  157.             error "requested $version, had [lindex $info 0]"
  158.             }
  159.         }
  160.         if {$type == "feature"} {
  161.             global package::loaded alpha::noMenusYet \
  162.               errorCode errorInfo global::features
  163.             package::activate $name
  164.             if {[lsearch -exact ${global::features} $name] == -1} {
  165.             lappend global::features $name
  166.             }
  167.         }
  168.         return [lindex $info 0]
  169.         }
  170.         if {!${alpha::rebuilding}} {
  171.         error "can't find package $name"
  172.         }
  173.     }
  174.     "uninstall" {
  175.         set name [lindex $args 0]
  176.         if {[llength $args] > 2} {
  177.         set version [lindex $args 1]
  178.         global alpha::rebuilding 
  179.         if {${alpha::rebuilding}} {
  180.             global rebuild_cmd_count index::uninstall pkg_file
  181.             switch -- [set script [lindex $args 2]] {
  182.             "this-file" {
  183.                 set script [list file delete $pkg_file]
  184.             }
  185.             "this-directory" {
  186.                 set script [list rm -r [file dirname $pkg_file]]
  187.             }
  188.             }
  189.             set index::uninstall($name) [list $version $pkg_file $script]
  190.             set args [lrange $args 3 end]
  191.             if {[llength $args]} {
  192.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  193.             return
  194.             }
  195.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  196.             return -code 11
  197.             }
  198.         }
  199.         } else {
  200.         cache::readContents index::uninstall
  201.         return [set index::uninstall($name)]
  202.         }
  203.     }
  204.     "forget" {
  205.         catch {unset index::feature($name)}
  206.     }
  207.     "exists" {
  208.         if {[package::getInfo] != ""} {return 1} else {return 0}
  209.     }
  210.     "type" {
  211.         if {[package::getInfo] != ""} {return $type} 
  212.         error "No such package"
  213.     }
  214.     "info" {
  215.         if {[llength [set info [package::getInfo]]]} {return [concat $type $info]} 
  216.         error "No such package"
  217.     }
  218.     "maintainer" -
  219.     "disable" -
  220.     "help" {
  221.         set name [lindex $args 0]
  222.         if {[llength $args] > 2} {
  223.         global alpha::rebuilding 
  224.         if {${alpha::rebuilding}} {
  225.             set version [lindex $args 1]
  226.             global rebuild_cmd_count index::$cmd
  227.             set data [lindex $args 2]
  228.             set index::${cmd}($name) [list $version $data]
  229.             set args [lrange $args 3 end]
  230.             if {[llength $args]} {
  231.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  232.             return
  233.             }
  234.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  235.             return -code 11
  236.             }
  237.         }
  238.         } else {
  239.         cache::readContents index::$cmd
  240.         return [set index::${cmd}($name)]
  241.         }
  242.     }
  243.     "versions" {
  244.         set info [package::getInfo]
  245.         if {[llength $info]} {
  246.         return [lindex $info 0]
  247.         }
  248.         error "No such package"
  249.     }
  250.     "vcompare" {
  251.         set c [eval package::_versionCompare $args]
  252.         if {$c > 0 || $c == -3} {
  253.         return 1
  254.         } elseif {$c == 0} {
  255.         return 0
  256.         } else {
  257.         return -1
  258.         }
  259.     }
  260.     "vsatisfies" {
  261.         if {[lindex $args 0] == "-loose"} {
  262.         set c [eval package::_versionCompare [lrange $args 1 end]]
  263.         return [expr {$c >= 0 || $c == -3 ? 1 : 0}]
  264.         } else {
  265.         set c [eval package::_versionCompare $args]
  266.         return [expr {$c >= 0 ? 1 : 0}]
  267.         }
  268.     }
  269.     "names" {
  270.         set names ""
  271.         package::getInfo
  272.         foreach type $which {
  273.         if {[array exists index::${type}]} {
  274.             eval lappend names [array names index::${type}]
  275.         }
  276.         }
  277.         return $names
  278.     }
  279.     "mode" -
  280.     "menu" -
  281.     "feature" {
  282.         eval alpha::$cmd $args
  283.     }
  284.     default {
  285.         error "Unknown option '$cmd' to 'package'"
  286.     }
  287.     }
  288. }
  289.  
  290. proc package::getInfo {{flags ""}} {
  291.     uplevel [list set flags $flags]
  292.     uplevel {
  293.     set name [lindex $args 0]
  294.     if {[regexp -- {-([^-].*)} $name "" which]} {
  295.         if {[lsearch $flags $which] != -1} {
  296.         set $which 1
  297.         set name [lindex $args 1]            
  298.         set args [lrange $args 1 end]            
  299.         return [package::getInfo $flags]
  300.         }
  301.         if {[lsearch {feature mode} $which] == -1} {
  302.         error "No such flag -$which"
  303.         }
  304.         set name [lindex $args 1]
  305.         set args [lrange $args 1 end]
  306.     } else {
  307.         set which {feature mode}
  308.     }
  309.     foreach type $which {
  310.         if {$type != "feature"} {cache::readContents index::${type}}
  311.         if {[info exists index::${type}($name)]} {
  312.         return [set index::${type}($name)]
  313.         }
  314.     }
  315.     return ""
  316.     }    
  317. }
  318.  
  319. ## 
  320.  # -------------------------------------------------------------------------
  321.  # 
  322.  # "package::_versionCompare" --
  323.  # 
  324.  #  This proc compares the two version numbers.  It returns:
  325.  #  
  326.  #  0 equal
  327.  #  1 equal but beta/patch update
  328.  #  2 equal but minor update
  329.  #  -1 beta/patch version older
  330.  #  -2 minor version older
  331.  #  -3 major version newer
  332.  #  -5 major version older
  333.  #  
  334.  #  i.e. >= 0 is basically ok, < 0 basically bad
  335.  #  
  336.  #  It works for beta, alpha, dev, fc and patch version numbers.
  337.  #  Any sequence of letters starting b,a,d,f,p are assumed to
  338.  #  represent the particular item.
  339.  #  
  340.  #  2.4 > 1.5 > 1.4.3 > 1.4.3b2 > 1.4.3b1 > 1.4.3a75 > 1.4p1 > 1.4
  341.  # -------------------------------------------------------------------------
  342.  ##
  343. proc package::_versionCompare {v1 v2} {
  344.     regsub -all -nocase {([a-z])[a-z]+} $v1 {\1} v1
  345.     regsub -all -nocase {([a-z])[a-z]+} $v2 {\1} v2
  346.     set v1 [split $v1 .p]
  347.     set v2 [split $v2 .p]
  348.     set i -1
  349.     set ret 0
  350.     set mult 2
  351.     while 1 {
  352.     incr i
  353.     set sv1 [lindex $v1 0]
  354.     set sv2 [lindex $v2 0]
  355.     if {$sv1 == "" && $sv2 == ""} { break }
  356.     if {$sv1 == ""} { 
  357.         set v1 [concat 8 0 $v1]
  358.         set v2 [concat 9 $v2]
  359.         continue
  360.     } elseif {$sv2 == ""} { 
  361.         set v1 [concat 9 $v1]
  362.         set v2 [concat 8 0 $v2]
  363.         continue
  364.     } elseif {[regexp -nocase {[a-z]} "$sv1$sv2"]} {
  365.         # beta versions
  366.         foreach v {sv1 sv2} {
  367.         if {[regexp -nocase {[a-z]} [set $v]]} {
  368.             # f = 8, b = 7, a = 6, d = 5
  369.             regsub -nocase {([^a-z])f} [set $v] {\1 7 } $v
  370.             regsub -nocase {([^a-z])b} [set $v] {\1 6 } $v
  371.             regsub -nocase {([^a-z])a} [set $v] {\1 5 } $v
  372.             regsub -nocase {([^a-z])d} [set $v] {\1 4 } $v
  373.         } else {
  374.             # release version = 8, so it is larger than any of the above
  375.             append $v " 8"
  376.         }
  377.         }
  378.         set v1 [eval lreplace [list $v1] 0 0 $sv1]
  379.         set v2 [eval lreplace [list $v2] 0 0 $sv2]
  380.         set mult 1
  381.         continue
  382.     }
  383.     if {$sv1 < $sv2} { set ret -1 ; break }
  384.     if {$sv1 > $sv2} { set ret 1 ; break }
  385.     set v1 [lrange $v1 1 end]
  386.     set v2 [lrange $v2 1 end]
  387.     }
  388.     if {$i == 0} {
  389.     # major version, return 0, -3, -5
  390.     return [expr {$ret * (-4*$ret + 1)}]
  391.     } else {
  392.     return [expr {$mult *$ret}]
  393.     }
  394. }
  395.  
  396. proc package::versionCheck {name vers} {
  397.     set av [alpha::package versions $name]
  398.     set c [package::_versionCompare $av $vers]
  399.     if {$c < 0 && $c != -3} {            
  400.     error "The installed version $av of '$name' is too old. Version $vers was requested."
  401.     } elseif {$c == -3} {            
  402.     error "The installed version $av of '$name' may not be backwards compatible with the requested version ($vers)."
  403.     }            
  404. }
  405.  
  406. proc package::reqInstalledVersion {name exact? {reqvers ""}} {
  407.     global index::feature
  408.     # called from installer
  409.     set msg " I suggest you abort the installation."
  410.     if {[info exists index::feature($name)]} {
  411.     if {[set exact?] == ""} {return}
  412.     set av [alpha::package versions $name]
  413.     if {[set exact?] == "-exact"} {
  414.         if {[alpha::package versions $name] != $reqvers} {
  415.         alertnote "The installed version $av of '$name' is incorrect.  Exact version $reqvers was requested.$msg"
  416.         }
  417.     } else {
  418.         set reqvers [set exact?]
  419.         if {$reqvers != ""} {        
  420.         set c [package::_versionCompare $av $reqvers]            
  421.         if {$c < 0 && $c != -3} {            
  422.             alertnote "The installed version $av of '$name' is too old. Version $reqvers was requested.$msg"
  423.         } elseif {$c == -3} {            
  424.             alertnote "The installed version $av of '$name' may not be backwards compatible with the requested version ($reqvers).$msg"
  425.         }             
  426.         }        
  427.     }
  428.     } else {
  429.     alertnote "This package requires the prior installation of '$name'. It is not currently installed.$msg"
  430.     }
  431. }
  432.  
  433. proc package::checkRequire {pkg} {
  434.     if {[catch {alpha::package require $pkg} error]} {
  435.     global errorInfo ; echo $errorInfo
  436.     if {[catch {alertnote "The '$pkg' package had an error starting up: $error"} ]} {
  437.         alertnote "The '$pkg' package had an error starting up"
  438.         echo $error
  439.     }
  440.     }    
  441. }
  442.  
  443.  
  444.  
  445. proc package::queryWebForList {} {
  446.     global defaultAlphaDownloadSite remote::site PREFS
  447.     set sitename [dialog::value_for_variable defaultAlphaDownloadSite "Query which site?"]
  448.     set nm [file join ${PREFS} _pkgtemp]
  449.     set siteurl [set remote::site($sitename)]
  450.     
  451.     catch {file delete $nm}
  452.     message "Fetching remote list…"
  453.     set type [url::fetch $siteurl $nm]
  454.     package::okGotTheList $sitename
  455. }
  456.  
  457. ## 
  458.  # -------------------------------------------------------------------------
  459.  # 
  460.  # "package::okGotTheList" --
  461.  # 
  462.  #  Helper proc which we can also call if the listing was interrupted
  463.  #  half-way through.
  464.  # -------------------------------------------------------------------------
  465.  ##
  466. proc package::okGotTheList {{sitename ""}} {
  467.     global defaultAlphaDownloadSite remote::site PREFS remote::lastsite
  468.     if {$sitename == ""} {
  469.     if {[info exists remote::lastsite]} {
  470.         set sitename ${remote::lastsite}
  471.         unset remote::lastsite
  472.     } else {
  473.         set sitename [dialog::value_for_variable defaultAlphaDownloadSite "From which site did you get the list?"]
  474.     }
  475.     }
  476.     set type [lindex [url::parse [set remote::site($sitename)]] 0]
  477.     set nm [file join ${PREFS} _pkgtemp]
  478.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  479.     alertnote "It looks like that application returned control\
  480.       to me before the download was complete (otherwise there was an error)\
  481.       -- probably Netscape/IE.  When it's done, or if there was an error\
  482.       hit Ok."
  483.     }
  484.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  485.     dialog::alert "There was a problem fetching the list --- if it's still\
  486.       being downloaded (you hit Ok too early!), wait till it's done \
  487.       and then select 'Ok Got The List'\
  488.       from the internet updates menu."
  489.     set remote::lastsite $sitename
  490.     enableMenuItem -m internetUpdates "Ok, Got The List" on
  491.     error "Error fetching list of new packages"
  492.     } else {
  493.     enableMenuItem -m internetUpdates "Ok, Got The List" off
  494.     }
  495.     set fd [open $nm "r"]
  496.     catch {set lines [split [read $fd] "\n\r"]}
  497.     close $fd
  498.     
  499.     if {[catch [list remote::process${type}Listing $lines] listing]} {
  500.     alertnote "Error interpreting list of new packages"
  501.     error "Error interpreting list of new packages"
  502.     }
  503.     message "Processing list…"
  504.     remote::processList $sitename $listing
  505.     message "Updated remote package information."
  506. }
  507.  
  508. proc package::active {pkg {text ""}} {
  509.     global global::features mode::features mode
  510.     if {[lsearch -exact ${global::features} $pkg] != -1 \
  511.       || ($mode != "" && ([lsearch -exact [set mode::features($mode)] $pkg] != -1))} {
  512.     if {[llength $text]} { return [lindex $text 0] } else {return 1 }
  513.     } else {
  514.     if {[llength $text]} { return [lindex $text 1] } else {return 0 }
  515.     }
  516. }
  517.  
  518. proc package::_editSite {{name ""} {loc ""}} {
  519.     if {$name == ""} {
  520.     set title "Name of new archive site"
  521.     set name "Ken's Alpha site"
  522.     set loc "ftp://ftp.ken.com/pub/Alpha/"
  523.     } else {
  524.     set title "Archive site name"
  525.     }
  526.     set y 10
  527.     set yb 105
  528.     set res [eval dialog -w 420 -h 135 \
  529.       [dialog::textedit $title $name 10 y 40] \
  530.       [dialog::textedit "URL for site" $loc 10 y 40] \
  531.       [dialog::okcancel 250 yb 0]]
  532.     if {[lindex $res 3]} { error "Cancel" } 
  533.     # cancel was pressed
  534.     return [lrange $res 0 1]    
  535. }
  536.  
  537.  
  538. proc package::addIndex {args} {
  539.     global index::feature pkg_file
  540.     cache::readContents index::feature
  541.     foreach f [concat $args] {
  542.     set pkg_file $f
  543.     message "scanning $f…"
  544.     catch {source $f}
  545.     }
  546.     cache::create index-extension "variable" index::feature
  547.     unset pkg_file
  548. }
  549.  
  550. proc package::helpFile {pkg {pointer 0}} {
  551.     # read help file instead
  552.     global HOME
  553.     set v [alpha::package versions $pkg]
  554.     if {[lindex $v 0] == "mode"} {
  555.     set v [lindex $v 1]
  556.     alertnote "The '$pkg' package is implemented by $v mode, and has no separate help.  I'll display the help for that mode instead."
  557.     set pkg $v
  558.     }
  559.     if {![catch {alpha::package help $pkg} res]} {
  560.     if {[lindex [set help [lindex $res 1]] 0] == "file"} {
  561.         if {$pointer} {
  562.         return "Help for this package is located in \"[lindex $help 1]\""
  563.         } else {
  564.         edit -r -c [file join ${HOME} Help [lindex $help 1]]
  565.         }
  566.     } elseif {[string index $help 0] == "\["} {
  567.         if {$pointer} {
  568.         return "You can read help for this package by holding 'shift' when\ryou select its name in the menu."
  569.         } else {
  570.         uplevel \#0 [string range $help 1 [expr {[string length $help] - 2}]]
  571.         }
  572.     } else {
  573.         if {$pointer} {
  574.         return $help
  575.         } else {
  576.         new -n "* '$pkg' Help *" -info \
  577.           "Help for package '$pkg', version [alpha::package versions $pkg]\r$help"
  578.         }
  579.     }
  580.     return
  581.     }
  582.     if {!$pointer} {
  583.     alertnote "Sorry, there isn't a help file for that package. You should contact the package maintainer."
  584.     }
  585.     return
  586. }
  587.  
  588. ## 
  589.  # -------------------------------------------------------------------------
  590.  # 
  591.  # "package::helpFilePresent" --
  592.  # 
  593.  #  Help files must be of the same name as the package (minus 'mode' or 
  594.  #  'menu'), but may have any combination of mode, menu, or help after
  595.  #  that name.  Whitespace is irrelevant.
  596.  # -------------------------------------------------------------------------
  597.  ##
  598. proc package::helpFilePresent {args} {
  599.     set res ""
  600.     cache::readContents index::help
  601.     foreach pkg $args {
  602.     lappend res [info exists index::help($pkg)]
  603.     }
  604.     return $res
  605. }
  606.  
  607. proc package::helpOrDescribe {pkg} {
  608.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  609.     if {$mods & 34} {
  610.         package::helpFile $pkg
  611.     } else {
  612.         package::describe $pkg
  613.     }
  614.     return 1
  615.     }
  616.     return 0
  617. }
  618.  
  619. # ◊◊◊◊ Specific to 'features' ◊◊◊◊ #
  620.  
  621. proc package::addRelevantMode {_feature mode} {
  622.     global index::feature
  623.     if {[info exists index::feature($_feature)]} {
  624.     if {[lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode] != -1} {
  625.         return
  626.     }
  627.     lappend oldm $mode
  628.     set index::feature($_feature) \
  629.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  630.     } else {
  631.     set index::feature($_feature) [list [list "mode" $mode] $mode]
  632.     }
  633. }
  634.  
  635. proc package::removeRelevantMode {_feature mode} {
  636.     global index::feature
  637.     if {[info exists index::feature($_feature)]} {
  638.     if {[set idx [lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode]] == -1} {
  639.         return
  640.     }
  641.     set oldm [lreplace $oldm $idx $idx ""]
  642.     set index::feature($_feature) \
  643.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  644.     }
  645. }
  646.  
  647. ## 
  648.  # -------------------------------------------------------------------------
  649.  # 
  650.  # "package::onOrOff" --
  651.  # 
  652.  #  Complicated procedure to accomplish a relatively simple task!
  653.  #  
  654.  #  Given a list of packages from chosen in a dialog, possibly with
  655.  #  '-' prefixes to indicate 'off', work out what changes have to
  656.  #  be made to the set of on/off features to synchronise everything.
  657.  #  
  658.  #  If 'global' that means the list was of the global packages rather
  659.  #  than those for the current mode.
  660.  # -------------------------------------------------------------------------
  661.  ##
  662. proc package::onOrOff {pkgs {lastMode ""} {global 0}} {
  663.     global mode::features global::features
  664.     set oldfeatures ""
  665.     set offfeatures ""
  666.     set onfeatures ""
  667.     set newfeatures ""
  668.     foreach m $pkgs {
  669.     if {[string index $m 0] == "-"} {
  670.         set m [string range $m 1 end]
  671.         if {[lsearch -exact ${global::features} $m] >= 0} {
  672.         lappend offfeatures $m
  673.         }
  674.     } else {
  675.         if {[lsearch -exact ${global::features} $m] < 0} {
  676.         lappend newfeatures $m
  677.         }
  678.     }
  679.     }
  680.     if {$global} {
  681.     # turn off those which aren't there
  682.     set offfeatures [lremove -l [set global::features] $pkgs]
  683.     }
  684.     if {[info exists mode::features($lastMode)]} {
  685.     foreach m [set mode::features($lastMode)] {
  686.         if {[string index $m 0] == "-"} {
  687.         set m [string range $m 1 end]
  688.         if {$global} {
  689.             lappend oldfeatures $m
  690.         } else {
  691.             if {[lsearch -exact ${global::features} $m] >= 0} {
  692.             if {[set ip [lsearch -exact $offfeatures $m]] < 0} {
  693.                 lappend newfeatures $m
  694.             } else {
  695.                 set offfeatures [lreplace $offfeatures $ip $ip]
  696.             }
  697.             }
  698.         }
  699.         } else {
  700.         if {$global} {
  701.             if {[set ip [lsearch -exact $offfeatures $m]] >= 0} {
  702.             set offfeatures [lreplace $offfeatures $ip $ip]
  703.             }
  704.         } else {
  705.             if {[lsearch -exact ${global::features} $m] < 0} {
  706.             lappend oldfeatures $m
  707.             if {[lsearch -exact $newfeatures $m] < 0} {
  708.                 lappend offfeatures $m
  709.             }
  710.             }
  711.         }
  712.         }
  713.     }
  714.     }
  715.     foreach m $newfeatures {
  716.     if {[lsearch -exact $oldfeatures $m] < 0} {
  717.         lappend onfeatures $m
  718.     }
  719.     }
  720.     return [list $offfeatures $onfeatures]
  721. }
  722.  
  723. proc package::partition {{mode ""}} {
  724.     global index::feature
  725.     set a ""
  726.     set b ""
  727.     set c ""
  728.     if {$mode == ""} {
  729.     # global case
  730.     foreach n [lsort -ignore [alpha::package names]] {
  731.         if {[info exists index::feature($n)]} {
  732.         switch -- [lindex [set index::feature($n)] 2] {
  733.             "1" {
  734.             lappend a $n
  735.             }
  736.             default {
  737.             lappend b $n
  738.             }
  739.         }
  740.         } else {
  741.         lappend c $n
  742.         }
  743.     }
  744.     return [list $a $b $c]
  745.     } else {
  746.     set d ""
  747.     set e ""
  748.     set f ""
  749.     set partition [array names index::feature]
  750.     if {$mode == "global"} {
  751.         set mode "global*"
  752.         set search "-glob"
  753.     } else {
  754.         set search "-exact"
  755.         global global::features
  756.         set partition [lremove -l $partition ${global::features}]
  757.     }        
  758.     foreach n [lsort -ignore $partition] {
  759.         set ff [set index::feature($n)]
  760.         switch -- [lindex $ff 2] {
  761.         "1" {
  762.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  763.             lappend a $n
  764.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  765.             lappend b $n
  766.             } elseif {[lindex $ff 1] != "global-only"} {
  767.             lappend c $n
  768.             }
  769.         }
  770.         "-1" {
  771.             # ignore auto-loading types
  772.         }
  773.         default {
  774.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  775.             lappend d $n
  776.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  777.             lappend e $n
  778.             } elseif {[lindex $ff 1] != "global-only"} {
  779.             lappend f $n
  780.             }
  781.         }
  782.         }
  783.     }
  784.     return [list $a $b $c $d $e $f]
  785.     }    
  786. }
  787.  
  788.  
  789. proc package::describe {pkg {return 0}} {
  790.     set info [alpha::package info $pkg]
  791.     set type [lindex $info 0]
  792.     set v [alpha::package versions $pkg]
  793.     if {[lindex $v 0] == "mode"} {
  794.     set v [lindex $v 1]
  795.     set msg "Package '$pkg', designed for use by $v mode is a"
  796.     } else {
  797.     set msg "Package '$pkg', version $v is a"
  798.     }
  799.     
  800.     switch -- $type {
  801.     "feature" {
  802.         switch -- [lindex $info 3] {
  803.         "1" {
  804.             append msg " menu, and is "
  805.             global global::menus
  806.             if {![lcontains global::features $pkg]} {
  807.             append msg "not "
  808.             }
  809.             append msg "in use."
  810.         }
  811.         "-1" {
  812.             append msg "n autoloading $type."
  813.         }
  814.         default {
  815.             append msg " $type, and is [package::active $pkg {active inactive}]."
  816.         }
  817.         }
  818.     }
  819.     "mode" {
  820.         append msg " $type; modes are always active."
  821.     }
  822.     }
  823.     cache::readContents index::maintainer
  824.     if {[info exists index::maintainer($pkg)]} {
  825.     set p [lindex [set index::maintainer($pkg)] 1]
  826.     append msg "\rMaintainer: [lindex $p 0], [lindex $p 1]\r"
  827.     append msg [lindex $p 2]
  828.     }
  829.     if {$return} {
  830.     return $msg
  831.     }
  832.     # let package tell us where its prefs are stored.
  833.     global alpha::prefs
  834.     if {[info exists alpha::prefs($pkg)]} {
  835.     set pkgpref [set alpha::prefs($pkg)]
  836.     } else {
  837.     set pkgpref $pkg
  838.     }
  839.     global ${pkgpref}modeVars
  840.     if {[array exists ${pkgpref}modeVars]} {
  841.     append msg "\r\r" [mode::describeVars $pkg $pkgpref]
  842.     new -n "* <$pkg> description *" -m Tcl -info $msg
  843.     } else {
  844.     alertnote $msg
  845.     }
  846. }
  847.  
  848. ## 
  849.  # -------------------------------------------------------------------------
  850.  # 
  851.  # "package::deactivate" --
  852.  # 
  853.  #  Turns off all the packages given.  This procedure must never throw an
  854.  #  error to its caller.
  855.  # -------------------------------------------------------------------------
  856.  ##
  857. proc package::deactivate {args} {
  858.     global index::feature alpha::noMenusYet
  859.     foreach pkg $args {
  860.     set info [set index::feature($pkg)]
  861.     if {[lindex $info 2] == 1} {
  862.         global $pkg
  863.         if {![info exists alpha::noMenusYet]} {
  864.         try::level \#0 "removeMenu \$$pkg\n[lindex $info 5]" \
  865.           -reporting log -while "deactivating $pkg"
  866.         continue
  867.         }
  868.     }
  869.     try::level \#0 [lindex $info 5] -reporting log -while "deactivating $pkg"
  870.     }
  871. }
  872.  
  873. ## 
  874.  # -------------------------------------------------------------------------
  875.  # 
  876.  # "package::activate" --
  877.  # 
  878.  #  Turns on all the packages given.  This procedure must never throw an
  879.  #  error to its caller.
  880.  # -------------------------------------------------------------------------
  881.  ##
  882. proc package::activate {args} {
  883.     global index::feature alpha::noMenusYet
  884.     foreach pkg $args {
  885.     set info [set index::feature($pkg)]
  886.     if {[set init [lindex $info 3]] != ""} {
  887.         message "Loading package '$pkg'…"
  888.         try::level \#0 $init -reporting log -while "initialising $pkg" 
  889.         set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  890.     }
  891.     if {[lindex $info 2] == 1} {
  892.         global $pkg
  893.         if {![info exists alpha::noMenusYet]} {
  894.         try::level \#0 "[lindex $info 4]\ninsertMenu \$$pkg" \
  895.           -reporting log -while "activating $pkg"
  896.         continue
  897.         }
  898.     }
  899.     try::level \#0 [lindex $info 4] -reporting log -while "activating $pkg"
  900.     }
  901. }
  902.  
  903. ## 
  904.  # -------------------------------------------------------------------------
  905.  # 
  906.  # "package::initialise" --
  907.  # 
  908.  #  Initialises all the packages given.  This procedure must never throw an
  909.  #  error to its caller.
  910.  # -------------------------------------------------------------------------
  911.  ##
  912. proc package::initialise {args} {
  913.     global index::feature
  914.     foreach pkg $args {
  915.     if {[set init [lindex [set index::feature($pkg)] 3]] != ""} {
  916.         message "Loading package '$pkg'…"
  917.         try::level \#0 $init -reporting log -while "initialising $pkg" 
  918.         set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  919.     }
  920.     }
  921. }
  922.  
  923. proc package::uninstall {} {
  924.     cache::readContents index::uninstall
  925.     if {![llength [set pkgs [array names index::uninstall]]]} {
  926.     alertnote "I don't know how to uninstall anything."
  927.     return
  928.     }
  929.     set pkgs [listpick -p "Permanently remove which packages/modes/menus?" -l [lsort -ignore $pkgs]]
  930.     if {![llength $pkgs]} { return }
  931.     if {![dialog::yesno "Are you absolutely sure you want to uninstall [join $pkgs {, }]?"]} { 
  932.     return 
  933.     }
  934.     global pkg_file
  935.     foreach pkg $pkgs {
  936.     set pkg_file [lindex [set index::uninstall($pkg)] 1]
  937.     set script [lindex [set index::uninstall($pkg)] 2]
  938.     if {[regexp "rm -r\[^\r\n\]*" $script check]} {
  939.         if {![dialog::yesno "The uninstaller for $pkg contains a\
  940.           recursive removal command '$check'. Do you want to do this?"]} { 
  941.         return 
  942.         }
  943.     }
  944.     if {[catch "uplevel \#0 [list $script]"]} {
  945.         alertnote "The uninstaller for $pkg had problems!"
  946.     }
  947.     }
  948.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  949.     quit
  950.     }
  951.     if {[dialog::yesno "All indices must then be rebuilt.\rShall I do this for you?"]} {
  952.     alpha::rebuildPackageIndices
  953.     rebuildTclIndices
  954.     } else {
  955.     alertnote "This will probably cause problems."
  956.     }
  957.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  958.     quit
  959.     }
  960. }
  961.  
  962. ## 
  963.  # -------------------------------------------------------------------------
  964.  # 
  965.  # "date::isOlder" --
  966.  # 
  967.  #  {Aug 22 1996} {Mar 26 22:17}
  968.  #  
  969.  # We assume the format is 'Month Day Year' or 'Month Day Time', where
  970.  # a time is distinguished by the presence of a colon.  Months have
  971.  # to be the standard three letter abbreviation (seems ok for all
  972.  # ftp and http servers I've come across)
  973.  # -------------------------------------------------------------------------
  974.  ##
  975. proc date::isOlder {a b} {
  976.     if {$a == $b} { return 0 }
  977.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $a "" am ad ay
  978.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $b "" bm bd by
  979.     # check year
  980.     regexp {[0-9]+$} [lindex [mtime [now] abbrev] 0] thisy
  981.     if {$ay == $thisy} { set ay "00:00" }
  982.     if {$by == $thisy} { set by "00:00" }
  983.     set a_ist [regexp : $ay]
  984.     set b_ist [regexp : $by]
  985.     if {!$a_ist && !$b_ist} {
  986.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  987.     }
  988.     if {$a_ist && !$b_ist} { return 0 }
  989.     if {!$a_ist && $b_ist} { return 1 }
  990.     # both are a year or both are times and both in last year
  991.     set months {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
  992.     # check we don't have a year wrap-around problem
  993.     set now_m [mtime [now] month]
  994.     set now_d [mtime [now] day]
  995.     set am [lsearch $months $am]
  996.     set bm [lsearch $months $bm]
  997.     set aprev [expr {($now_m < $am || ($now_m == $am && $now_d < $ad))}]
  998.     set bprev [expr {($now_m < $bm || ($now_m == $bm && $now_d < $bd))}]
  999.     if {$aprev && !$bprev} {return 1}
  1000.     if {!$aprev && $bprev} {return 0}
  1001.     # both in same year: continue
  1002.     if {$am < $bm} { return 1 } elseif {$bm < $am} { return 0 }
  1003.     if {$ad < $bd} { return 1 } elseif {$bd < $ad} { return 0 }
  1004.     if {$a_ist && $b_ist} {
  1005.     regsub {:} $ay {.} ay
  1006.     regsub {:} $by {.} by
  1007.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  1008.     } 
  1009.     # same !
  1010.     return 0
  1011. }
  1012.  
  1013.  
  1014. # ◊◊◊◊ Handle remote menu ◊◊◊◊ #
  1015. proc package::menuProc {menu item} {
  1016.     global remote::site modifiedArrVars defaultAlphaDownloadSite
  1017.     switch -- $item {
  1018.     "Describe A Package" {
  1019.         set pkg [dialog::optionMenu "Describe which package?" \
  1020.           [lsort -ignore [alpha::package names]]]
  1021.         package::describe $pkg
  1022.     }
  1023.     "Read Help For A Package" {
  1024.         set pkg [dialog::optionMenu "Read help for which package?" \
  1025.           [lsort -ignore [alpha::package names]]]
  1026.         package::helpFile $pkg
  1027.     }
  1028.     "Uninstall Some Packages" {
  1029.         package::uninstall
  1030.     }
  1031.     "rebuildPackageIndex" {
  1032.         alpha::rebuildPackageIndices
  1033.     }
  1034.     "listPackages" {
  1035.         global::listPackages
  1036.     }
  1037.     "installBugFixesFrom" {
  1038.         # this item isn't in the menu by default anymore.
  1039.         set f [getfile "Select a bug-fix file…"]
  1040.         procs::patchOriginalsFromFile $f 1
  1041.     }
  1042.     "Update List From A Web Archive Site" {
  1043.         package::queryWebForList
  1044.     }
  1045.     "Ok, Got The List" {
  1046.         package::okGotTheList
  1047.     }
  1048.     "Add Web Or Ftp Archive Site" {
  1049.         array set remote::site [package::_editSite]
  1050.         lappend modifiedArrVars remote::site
  1051.     }
  1052.     "Edit Web Or Ftp Archive Site" {
  1053.         set sitename [dialog::optionMenu "Edit which site?" \
  1054.           [lsort -ignore [array names remote::site]]]
  1055.         
  1056.         array set remote::site \
  1057.           [package::_editSite $sitename [set remote::site($sitename)]]
  1058.         lappend modifiedArrVars remote::site
  1059.     }
  1060.     "Remove Web Or Ftp Archive Site" {
  1061.         set sitename [dialog::optionMenu "Remove which site?" \
  1062.           [lsort -ignore [array names remote::site]]]
  1063.         unset remote::site($sitename)
  1064.         lappend modifiedArrVars remote::site
  1065.     }
  1066.     "Describe Item" {
  1067.         alertnote "Select one of the packages, and I'll tell you\
  1068.           when it was last modified, and from where it would be downloaded."
  1069.     }
  1070.     "Ignore Item" {
  1071.         alertnote "'Ignoring' a package tells me to remove it from\
  1072.           new and updated package lists.  It'll still be listed lower\
  1073.           down in the menu"
  1074.     }
  1075.     "Select Item To Download" {
  1076.         alertnote "Select one of the packages, and it will be\
  1077.           downloaded from its site on the internet, decompressed\
  1078.           and installed."
  1079.     }
  1080.     default {
  1081.         remote::get $item
  1082.     }
  1083.     }
  1084.     
  1085. }
  1086.  
  1087.  
  1088. proc package::makeUpdateMenu {} {
  1089.     global remote::listing
  1090.     set l [list \
  1091.       "Update List From A Web Archive Site…" \
  1092.       "(Ok, Got The List" \
  1093.       "<E<SRemove Web Or Ftp Archive Site…" \
  1094.       "<S<BEdit Web Or Ftp Archive Site…" \
  1095.       "<SAdd Web Or Ftp Archive Site…" "(-" \
  1096.       "<S[menu::itemWithIcon {Describe Item} 81]" \
  1097.       "<S<U[menu::itemWithIcon {Ignore Item} 81]" \
  1098.       "<S[menu::itemWithIcon {Select Item To Download} 81]" ]
  1099.     foreach a ${remote::listing} {
  1100.     set type [lindex $a 1]
  1101.     regsub -all {\.(sea|tar|gz|zip|sit|bin|hqx)} [lindex $a 2] "" name
  1102.     lappend [lindex {other gone new uptodate update} [expr {$type + 2}]] $name
  1103.     if {$type == -1} {
  1104.         lappend disable $name
  1105.     }
  1106.     }
  1107.     if {[info exists update]} {
  1108.     lappend l "(-" "/\x1e(Updated items^[text::Ascii 79 1]"
  1109.     eval lappend l [lsort -ignore $update]
  1110.     }
  1111.     if {[info exists new]} {
  1112.     lappend l "(-" "/\x1e(New items^[text::Ascii 79 1]"
  1113.     eval lappend l [lsort -ignore $new]
  1114.     }
  1115.     if {[info exists uptodate]} {
  1116.     lappend l "(-" "(Current items"
  1117.     eval lappend l [lsort -ignore $uptodate]
  1118.     }
  1119.     if {[info exists other]} {
  1120.     lappend l "(-" "(Other items"
  1121.     eval lappend l [lsort -ignore $other]
  1122.     }
  1123.     if {[info exists gone]} {
  1124.     lappend l "(-" "(Vanished items"
  1125.     eval lappend l [lsort -ignore $gone]
  1126.     }
  1127.     Menu -n "internetUpdates" -m -p package::menuProc $l
  1128.     if {[info exists disable]} {
  1129.     foreach a $disable {
  1130.         enableMenuItem "internetUpdates" $a off
  1131.     }
  1132.     }
  1133. }
  1134.  
  1135. proc remote::processftpListing {lines} {
  1136.     set files {}
  1137.     foreach f [lrange [lreplace $lines end end] 1 end] {
  1138.     set nm [lindex $f end]
  1139.     if {[string length $nm]} {
  1140.         if {[string match "d*" $f]} {
  1141.         #lappend files "$nm/"
  1142.         } else {
  1143.         regexp {[A-Z].*$} [lreplace $f end end] time
  1144.         set date [lindex $time end]
  1145.         if {[regexp : $date] || ![regexp {^19[89][0-5]$} $date]} {
  1146.             # reject anything pre 1996
  1147.             lappend files [list $nm $time]
  1148.         }
  1149.         }
  1150.     }
  1151.     }
  1152.     return $files
  1153. }
  1154.  
  1155. ## 
  1156.  # -------------------------------------------------------------------------
  1157.  # 
  1158.  # "remote::processhttpListing" --
  1159.  # 
  1160.  #  Extract all things like  <A HREF="/~vince/pub/">Parent Directory</A>
  1161.  #  followed by a date.  Massage the date into 'Month day year'.
  1162.  #  
  1163.  #  I don't know if this will work for all http servers!  It works for
  1164.  #  mine.
  1165.  # -------------------------------------------------------------------------
  1166.  ##
  1167. proc remote::processhttpListing {lines} {
  1168.     set files {}
  1169.     foreach f $lines {
  1170.     if {[regexp {<A HREF="([^"]*)">.*</A>[ \t]*([^ \t]+)[ \t]} $f "" name date]} {
  1171.         if {![regexp {/$} $name]} {
  1172.         if {![regexp {[89][0-5]$} $date]} {
  1173.             # reject anything pre 1996
  1174.             set date [split $date -]
  1175.             set md "[lindex $date 1] [lindex $date 0] "
  1176.             append md [expr {[lindex $date 2] < 80 ? 20 : 19}]
  1177.             append md [lindex $date 2]
  1178.             lappend files [list $name $md]
  1179.         }
  1180.         }
  1181.     }
  1182.     }
  1183.     return $files
  1184. }
  1185.  
  1186. proc remote::versionOneNewer {one two} {
  1187.     return 1
  1188. }
  1189.  
  1190. proc remote::processList {sitename {l ""}} {
  1191.     global remote::listing modifiedVars
  1192.     # removed vanished items from the menu
  1193.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $l "" ll
  1194.     foreach i ${remote::listing} {
  1195.     if {[string match "*${sitename}*" $i]} {
  1196.         regsub -all {(\.|-)([0-9]+([a-zA-Z][0-9]+)?)} \
  1197.           [set ii [lindex $i 2]] "" ii
  1198.         if {[lsearch -glob $ll "$ii *"] == -1} {
  1199.         # it's vanished
  1200.         lappend removed $i
  1201.         lappend _removed [lindex $i 0]
  1202.         }
  1203.     }
  1204.     }
  1205.     if {[info exists removed]} {
  1206.     set remote::listing [lremove -l ${remote::listing} $removed]
  1207.     }
  1208.     # process new items
  1209.     foreach i $l {
  1210.     set namepart [lindex $i 0]
  1211.     set timepart [lindex $i 1]
  1212.     regsub -all {\.(sea|tar|tgz|gz|zip|sit|bin|hqx)} $namepart "" name
  1213.     regsub -all {(\.|-|_)[0-9]+([a-zA-Z][0-9]+)?} $name "" name
  1214.     if {[set idx [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]] != -1} {
  1215.         # update old item
  1216.         set item [lindex ${remote::listing} $idx]
  1217.         if {[lindex $item 2] != $namepart} {
  1218.         # it's changed
  1219.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1220.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1221.         lappend _updated $name
  1222.         } elseif {[date::isOlder [lindex $item 3] $timepart]} {
  1223.         # date has changed
  1224.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1225.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1226.         lappend _updated $name
  1227.         }
  1228.     } else {
  1229.         # new package
  1230.         lappend remote::listing [list $name 0 $namepart $timepart $sitename]
  1231.         lappend _new $name
  1232.     }
  1233.     
  1234.     }
  1235.     lappend modifiedVars remote::listing
  1236.     package::makeUpdateMenu
  1237.     ensureset _updated "none"
  1238.     ensureset _new "none"
  1239.     ensureset _removed "none"
  1240.     if {[catch {alertnote "Remote information, NEW: $_new, UPDATED: $_updated, REMOVED: ${_removed}."}]} {
  1241.     alertnote "Remote information, [llength $_new] new, [llength $_updated] updated and [llength $_removed] packages removed."
  1242.     }
  1243. }
  1244. proc remote::updateDatabase {idx val} {
  1245.     global remote::listing
  1246.     set item [lindex ${remote::listing} $idx]
  1247.     if {[lindex $item 1] != $val} {
  1248.     # it's changed
  1249.     set item [lreplace $item 1 1 $val]
  1250.     set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1251.     }
  1252. }
  1253.  
  1254. proc remote::pkgIndex {name} { 
  1255.     global remote::listing
  1256.     if {[set i [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]] == -1} {
  1257.     set i [lsearch -glob ${remote::listing} \
  1258.       "[quote::Find [string toupper [string index ${name} 0]][string range $name 1 end]] *"]
  1259.     }
  1260.     return $i
  1261. }
  1262.  
  1263. proc remote::pkgDetails {name} { 
  1264.     global remote::listing
  1265.     set idx [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]
  1266.     return [lindex ${remote::listing} $idx]
  1267. }
  1268.  
  1269. proc remote::get {pkg} {
  1270.     global remote::listing HOME remote::site downloadFolder file::separator
  1271.     # get pkg
  1272.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1273.     regsub -all {(\.|-|_)[0-9]+([a-zA-Z][0-9]+)?} $pkg "" pkg
  1274.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1275.         alertnote "Sorry, I don't know from where to download that package."
  1276.         error ""
  1277.     }
  1278.     }
  1279.     set item [lindex ${remote::listing} $idx]
  1280.     
  1281.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  1282.     if {$mods & 34} {
  1283.         # just shift key demote the item in the hierarchy
  1284.         set itm [lindex $item 1]
  1285.         if {$itm == 0 || $itm == 2} { set itm 1 } else { set itm -2 }
  1286.         set item [lreplace $item 1 1 $itm]
  1287.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1288.         global modifiedVars
  1289.         lappend modifiedVars remote::listing
  1290.         package::makeUpdateMenu
  1291.         message "Package '$pkg' demoted."
  1292.         return
  1293.     } else {
  1294.         # describe the item
  1295.         alertnote "File '[lindex $item 2]', last modified [lindex $item 3], to be downloaded from [lindex $item 4], at [set remote::site([lindex $item 4])]"
  1296.         return
  1297.     }
  1298.     }
  1299.     set file [lindex $item 2]
  1300.     set sitename [lindex $item 4]
  1301.     # get the file
  1302.     if {![file exists $downloadFolder] || ![file isdirectory $downloadFolder]} {
  1303.     alertnote "Your Download Folder does not exist.  I'll download to Alpha's home directory."
  1304.     set downloadFolder $HOME
  1305.     }
  1306.     if {[catch {url::fetchFrom [set remote::site($sitename)] ${downloadFolder}${file::separator} $file} err]} {
  1307.     alertnote "Fetch error '$err'"
  1308.     error ""
  1309.     }
  1310.     set ff [file join $downloadFolder $file]
  1311.     if {![file exists $ff] || (![file writable $ff]) || (![file size $ff])} {
  1312.     dialog::alert "It looks like that application returned control to\
  1313.       me before the download was complete (otherwise there was an error)\
  1314.       -- probably Netscape/IE.\r\rWhen it's done, or if there was an error\
  1315.       hit Ok."
  1316.     }
  1317.     # update database
  1318.     remote::updateDatabase $idx 1
  1319.     package::makeUpdateMenu
  1320.     # decompress it
  1321.     file::decompress [file join ${downloadFolder} $file]
  1322.     set filepre [lindex [split $file .] 0]
  1323.     # install
  1324.     set files [glob -t TEXT -nocomplain -path [file join ${downloadFolder} ${filepre}] -- *]
  1325.     set realfiles {}
  1326.     foreach f $files {
  1327.     if {![file isdir $f]} {
  1328.         lappend realfiles $f
  1329.     }
  1330.     }
  1331.     set files $realfiles
  1332.     if {[llength $files] == 0} {
  1333.     # look for directory
  1334.     set dirs [glob -nocomplain -t d -path [file join ${downloadFolder} ${filepre}] -- *]
  1335.     if {[llength $dirs] == 1} {
  1336.         set local [lindex $dirs 0]
  1337.         set files [lunique [glob -t TEXT -nocomplain -path $local -- "*\[i|I\]{nstall,NSTALL}"]]
  1338.     } else {
  1339.         set files ""
  1340.         set local $downloadFolder
  1341.     }
  1342.     }
  1343.     if {[llength $files] == 0} {
  1344.     alertnote "I can't find a suitable, unique install file.  You must find it yourself."
  1345.     # open dir in finder
  1346.     openFolder $local
  1347.     return
  1348.     }
  1349.     if {[llength $files] > 1} {
  1350.     set f [listpick -p "Which file is the installer?" $files]
  1351.     } else {
  1352.     set f [lindex $files 0]
  1353.     }
  1354.     edit $f
  1355.     global mode
  1356.     if {$mode != "Inst"} {
  1357.     alertnote "I don't know what to do with this package from here."
  1358.     } else {
  1359.     if {[dialog::yesno "You can install this extension from the install menu.\rShall I do that for you?"]} {
  1360.         install::installThisPackage
  1361.     }
  1362.     }
  1363. }
  1364.  
  1365.  
  1366.  
  1367.  
  1368.  
  1369.  
  1370.  
  1371.  
  1372.  
  1373.